
######################################################################################
## $Id: App.pm 3666 2006-03-11 20:34:10Z spadkins $
######################################################################################
## Note: Much of this code is borrowed from Apache::DBI
##       In doing so, I have made a half-hearted attempt to make this mod_perl 1.X compatible.
##       However, I have never run it on mod_perl 1.X, only on mod_perl 2.X.
##       When someone debugs this on mod_perl 1.X, please let me know what you had to do to make it work.
######################################################################################

package Apache::App;
use strict;
our $VERSION = (q$Revision: 3666 $ =~ /(\d[\d\.]*)/)[0];

use base qw(ModPerl::RegistryCooker);

use constant MP2 => (exists $ENV{MOD_PERL_API_VERSION} &&
                            $ENV{MOD_PERL_API_VERSION} == 2) ? 1 : 0;

BEGIN {
    if (MP2) {
        require mod_perl2;
        require Apache2::Module;
        require Apache2::RequestUtil;
        require Apache2::ServerUtil;
        require Apache2::Const;
        require Apache::DBI;

        my $s = Apache2::ServerUtil->server;
        $s->push_handlers(PerlChildInitHandler => \&child_init_handler);
        $s->push_handlers(PerlChildExitHandler => \&child_exit_handler);
        $s->push_handlers(PerlResponseHandler  => \&request_handler);
        $s->push_handlers(PerlCleanupHandler   => \&request_cleanup_handler);
    }
    elsif (defined $modperl::VERSION && $modperl::VERSION > 1 && $modperl::VERSION < 1.99) {
        require Apache;
        require Apache::DBI;

        Carp::carp("Apache.pm was not loaded\n")
              and return unless $INC{'Apache.pm'};

        if (Apache->can('push_handlers')) {
            Apache->push_handlers(PerlChildInitHandler => \&child_init_handler);
            Apache->push_handlers(PerlChildExitHandler => \&child_exit_handler);
            Apache->push_handlers(PerlResponseHandler  => \&request_handler);
            Apache->push_handlers(PerlCleanupHandler   => \&request_cleanup_handler);
        }
    }
}

use Carp ();
use App::Options;
use App;

##-BEGIN-OF-Apache::Registry-CODE-####################################################
# The following section of code is lifted from ModPerl::Registry and modified.

sub request_handler : method {
    warn("$$ Apache::App::request_handler(@_)\n");
    my $class = (@_ >= 2) ? shift : __PACKAGE__;
    my $r = shift;

    my $app_apache     = $class->new($r);

    my $prog           = $app_apache->{FILENAME};   # (same as $r->filename())
    $prog              =~ s/\\/\//g;
    my $prog_dir       = $prog;
    $prog_dir          =~ s!/[^/]+$!!;
    my $prog_file      = $prog;
    $prog_file         =~ s!.*/!!;

    my $app            = App::Options->determine_app($ENV{PREFIX}, $prog_dir, $prog_file, $r->path_info());
    $app_apache->prepare_context($app, $app_apache->{FILENAME});

    # Then we run the request and return the result (Apache2::Const::OK)
    my $request_result = $app_apache->default_handler();

    warn("$$ Apache::App     app =[$app]\n");
    warn("$$ Apache::App.REQ     =[$app_apache->{REQ}]\n");
    warn("$$ Apache::App.URI     =[$app_apache->{URI}]\n");
    warn("$$ Apache::App.FILENAME=[$app_apache->{FILENAME}]\n");

    return $request_result;
}

my $parent_class = "ModPerl::RegistryCooker";
my $self_class   = __PACKAGE__;

# the following code:
# - specifies package's behavior different from default of $parent class
# - speeds things up by shortcutting @ISA search, so even if the
#   default is used we still use the alias
my %aliases = (
    new             => "${parent_class}::new",
    init            => "${parent_class}::init",
    default_handler => "${parent_class}::default_handler",
    run             => "${parent_class}::run",
    can_compile     => "${parent_class}::can_compile",
    make_namespace  => "${parent_class}::make_namespace",
    namespace_root  => "${parent_class}::namespace_root",
    namespace_from  => "${parent_class}::namespace_from_filename",
    is_cached       => "${parent_class}::is_cached",
    should_compile  => "${parent_class}::should_compile_if_modified",
    flush_namespace => "${parent_class}::NOP",
    cache_table     => "${parent_class}::cache_table_common",
    cache_it        => "${parent_class}::cache_it",
    read_script     => "${parent_class}::read_script",
    shebang_to_perl => "${parent_class}::shebang_to_perl",
    get_script_name => "${parent_class}::get_script_name",
    chdir_file      => "${parent_class}::NOP",
    get_mark_line   => "${parent_class}::get_mark_line",
    compile         => "${parent_class}::compile",
    error_check     => "${parent_class}::error_check",
    strip_end_data_segment             => "${parent_class}::strip_end_data_segment",
    convert_script_to_compiled_handler => "${parent_class}::convert_script_to_compiled_handler",
);

$self_class->install_aliases(\%aliases);

##-END-OF-Apache::Registry-CODE-######################################################

######################################################################################
# Variables
######################################################################################

my (@service_on_init);             # services to be initialized when a new httpd child is created
#my %env = %ENV;
my (%options, %context);

######################################################################################
# This is supposed to be called in a startup script or in httpd.conf (<Perl> section).
######################################################################################

sub import {
    # save global values initialized up until now
    App->context() if (!$App::context);
    Apache::App->save_context("main");
}

sub save_context {
    my ($self, $app) = @_;
    $options{$app} = { %App::options };
    $context{$app} = $App::context;
}

sub restore_context {
    my ($self, $app) = @_;

    if ($options{$app}) {
        %App::options = %{$options{$app}};
    }
    else {
        %App::options = ();
    }

    if ($context{$app}) {
        $App::context = $context{$app};
    }
    else {
        $App::context = undef;
    }
}

sub clear_context {
    my ($self) = @_;
    %App::options = ();
    $App::context = undef;
}

#sub determine_app_from_request {
#    my ($self, $r) = @_;
#}

######################################################################################
# This is supposed to be called in a startup script or in httpd.conf (<Perl> section).
######################################################################################

sub prepare_context {
    warn("$$ Apache::App::prepare_context(@_)\n");
    my ($self, $app, $program) = @_;
    if (!$context{$app} || !$options{$app}) {
        $self->clear_context() if ($context{$app} || $options{$app});
        my $prefix = $ENV{PREFIX} || $options{main}{prefix} || "/usr/local/app";
        %App::options = (
            app           => $app,
            prefix        => $prefix,
            context_class => "App::Context::ModPerl",
        );
        my $option_processor = App::Options->new({
            init_args => {
                no_cmd_args => 1,
                no_env_vars => 1,
                option => {
                    session_class => { default => "App::Session::HTMLHidden", },
                    request_class => { default => "App::Request::CGI", },
                },
            },
        });
        local($0) = $program;
        $option_processor->read_options(\%App::options);
        my $context = App->context();
        $self->save_context($app);
    }
    elsif ($context{$app} ne $App::context) {
        $self->restore_context($app);
    }
}

######################################################################################
# Upon child server startup (PerlChildInitHandler), services should be initialized
# which may include repositories and hence possible connections to databases.
######################################################################################

sub init_service_on_child_init {
    warn("$$ Apache::App::init_service_on_child_init(@_)\n");
    my ($self, $app, @args) = @_;
    push(@service_on_init, [$app, @args]);
    warn("$$ Apache::App::init_service_on_child_init() : \$#service_on_init = [$#service_on_init]\n");
}

######################################################################################
# PerlChildInitHandler : runs during child server startup.
######################################################################################
# Note: this handler runs in every child server, but not in the main server.
######################################################################################

sub child_init_handler {
    my ($child_pool, $s) = @_;
    warn("$$ Apache::App::child_init_handler(@_) : \$#service_on_init = [$#service_on_init]\n");

    my ($app, $service);
    if ($#service_on_init > -1) {
        foreach my $service_init_args (@service_on_init) {
            warn("$$ Apache::App::child_init_handler() : service_init_args=[@$service_init_args]\n");
            $app = shift(@$service_init_args);
            warn("$$ Apache::App::child_init_handler() : context($app).service(@$service_init_args)\n");
            App::Apache->prepare_context($app);
            $service = $App::context->service(@$service_init_args);
            warn("$$ Apache::App::child_init_handler() : context($app).service(@$service_init_args) = [$service]\n");
        }
    }

    return 1;
}

######################################################################################
# PerlChildExitHandler : runs during child server shutdown.
######################################################################################

sub child_exit_handler {
    my ($child_pool, $s) = @_;
    warn("$$ Apache::App::child_exit_handler(@_)\n");
    return 1;
}

######################################################################################
# PerlCleanupHandler : runs after the response has been sent to the client
######################################################################################

sub request_cleanup_handler {
    warn("$$ Apache::App::request_cleanup_handler(@_)\n");
#    my $Idx = shift;
#
#    my $prefix = "$$ Apache::DBI            ";
#    debug(2, "$prefix PerlCleanupHandler");
#
#    my $dbh = $Connected{$Idx};
#    if ($Rollback{$Idx}
#        and $dbh 
#        and $dbh->{Active}
#        and !$dbh->{AutoCommit}
#        and eval {$dbh->rollback}) {
#        debug (2, "$prefix PerlCleanupHandler rollback for '$Idx'");
#    }
#
#    delete $Rollback{$Idx};
#
    1;
}

######################################################################################
# Response Handler
######################################################################################

#sub handler {
#    my $r = shift;
#
#    if ($ENV{PATH_INFO} eq "/_info") {
#        &info($r);
#        return;
#    }
#
#    my ($msg, $response);
#
#    # INITIALIZE THE CONTEXT THE FIRST TIME THIS APACHE CHILD PROCESS
#    # RECEIVES A REQUEST (should I do this sooner? at child init?)
#    # (so that the first request does not need to bear the extra burden)
#
#    # Also, the App class would cache the $context for me
#    # if I didn't want to cache it myself. But then I would have to 
#    # prepare the %options every request. hmmm...
#    # I don't suppose the $r->dir_config() call is expensive.
#
#    if (!defined $context) {
#        my %options = %{$r->dir_config()};
#        $options{context_class} = "App::Context::ModPerl" if (!defined $options{context_class});
#        eval {
#            $context = App->context(\%options);
#        };
#        $msg = $@ if ($@);
#    }
#
#    if ($ENV{PATH_INFO} eq "/_context") {
#        my $header = <<EOF;
#Content-type: text/plain
#
#App::Context::ModPerl - Context
#
#EOF
#        $r->print($header);
#        $r->print($context->dump());
#        return;
#    }
#    elsif ($ENV{PATH_INFO} eq "/_session") {
#        my $header = <<EOF;
#Content-type: text/plain
#
#App::Context::ModPerl - Session
#
#EOF
#        $r->print($header);
#        $r->print($context->{session}->dump());
#        return;
#    }
#    elsif ($ENV{PATH_INFO} eq "/_conf") {
#        my $header = <<EOF;
#Content-type: text/plain
#
#App::Context::ModPerl - Conf
#
#EOF
#        $r->print($header);
#        $r->print($context->{conf}->dump());
#        return;
#    }
#    elsif ($ENV{PATH_INFO} eq "/_options") {
#        my $header = <<EOF;
#Content-type: text/plain
#
#App::Context::ModPerl - Options
#
#EOF
#        $r->print($header);
#        my $options = $context->{options} || {};
#        foreach my $key (sort keys %$options) {
#            $r->print("$key = $options->{$key}\n");
#        }
#        return;
#    }
#
#    # this should always be true
#    if (defined $context) {
#        # the response will be emitted from within dispatch_events()
#        $context->dispatch_events();
#    }
#    else {
#        # we had an error (maybe App-Context not installed? Perl @INC not set?)
#        $response = <<EOF;
#Content-type: text/plain
#
#Unable to create an App::Context.
#$msg
#
#EOF
#        $r->print($response);
#    }
#}

######################################################################################
# Special URL-driven Responses
######################################################################################

#sub info {
#    my $r = shift;
#    my $header = <<EOF;
#Content-type: text/plain
#
#Welcome to Apache::App
#
#EOF
#    $r->print($header);
#    print $r->as_string();
#    $r->print("\n");
#    $r->print("ENVIRONMENT VARIABLES\n");
#    $r->print("\n");
#    foreach my $var (sort keys %ENV) {
#        $r->print("$var=$ENV{$var}\n");
#    }
#    $r->print("\n");
#    $r->print("ENVIRONMENT VARIABLES (at startup)\n");
#    $r->print("\n");
#    foreach my $var (sort keys %env) {
#        $r->print("$var=$env{$var}\n");
#    }
#    $r->print("\n");
#    $r->print("DIRECTORY CONFIG\n");
#    $r->print("\n");
#    my %options = %{$r->dir_config()};
#    foreach my $var (sort keys %options) {
#        $r->print("$var=$options{$var}\n");
#    }
#}

# prepare menu item for Apache::Status
#sub status_function {
#    my($r, $q) = @_;
#
#    my(@s) = qw(<TABLE><TR><TD>Datasource</TD><TD>Username</TD></TR>);
#    for (1 .. 5) {
#        push @s, '<TR><TD>',
#            join('</TD><TD>',
#                 ($_, "tbd"), "</TD></TR>\n";
#    }
#    push @s, '</TABLE>';
#
#    \@s;
#}

#if (MP2) {
#    if (Apache2::Module::loaded('Apache2::Status')) {
#	    Apache2::Status->menu_item(
#                                   'DBI' => 'DBI connections',
#                                    \&status_function
#                                  );
#    }
#}
#else {
#   if ($INC{'Apache.pm'}                       # is Apache.pm loaded?
#       and Apache->can('module')               # really?
#       and Apache->module('Apache::Status')) { # Apache::Status too?
#       Apache::Status->menu_item(
#                                'DBI' => 'DBI connections',
#                                \&status_function
#                                );
#   }
#}

1;

